home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol117 / listmar.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-12-15  |  4.6 KB  |  181 lines
  1. 90  WIDTH "scrn:", 80
  2. 95  SCREEN 0,1,0,0
  3. 100  TITLE$ = "List the Marriages File Program"
  4. 105  TITLE$ = TITLE$ + " ON DISPLAY"
  5. 110  VERSION$ = "Version 3.0"
  6. 115  COPY1$ = "Copyright (c) 1983, 1984, 1985, by:"
  7. 120  COPY2$ = "Melvin O. Duke"
  8. 125  PRICE$ = "$35"
  9. 130  ADDR1$ = "Melvin O. Duke"
  10. 135  ADDR2$ = "P. O. Box 20836"
  11. 140  ADDR3$ = "San Jose, CA  95160"
  12. 145  REM Dimension Statements go here
  13. 170  REM Produce the first screen
  14. 175  KEY OFF : CLS
  15. 180  REM Draw the outer double box
  16. 185  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  17. 190  REM Find the title location
  18. 195  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  19. 200  REM Draw the title box
  20. 205  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  21. 210  REM Print the title
  22. 215  LOCATE 4,TITLE.POS : PRINT TITLE$
  23. 220  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  24. 225  REM Draw the Contribution box
  25. 230  R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  26. 235  REM Request the Contribution
  27. 240  LOCATE 9,23 : PRINT "If you are using these programs, and"
  28. 245  LOCATE 10,21 : PRINT "finding them of value, your contribution"
  29. 250  LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be anticipated."
  30. 255  REM Draw the Mailing Label
  31. 260  R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  32. 265  REM Print the Name and Address
  33. 270  LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  34. 275  LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  35. 280  LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  36. 285  REM Draw the Copyright box
  37. 290  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 400
  38. 295  REM Print the Copyright
  39. 300  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  40. 305  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  41. 310  GOTO 740
  42. 400  REM subroutine to print a double box
  43. 405  COLOR 5
  44. 410  FOR I = R1 + 1 TO R2 - 1
  45. 420   LOCATE I, C1 : PRINT CHR$(186);
  46. 430   LOCATE I, C2 : PRINT CHR$(186);
  47. 440  NEXT I
  48. 450  FOR J = C1 + 1 TO C2 - 1
  49. 460   LOCATE R1, J : PRINT CHR$(205);
  50. 470   LOCATE R2, J : PRINT CHR$(205);
  51. 480  NEXT J
  52. 490   LOCATE R1, C1 : PRINT CHR$(201);
  53. 500   LOCATE R1, C2 : PRINT CHR$(187);
  54. 510   LOCATE R2, C1 : PRINT CHR$(200);
  55. 520   LOCATE R2, C2 : PRINT CHR$(188);
  56. 525  COLOR 7
  57. 530  RETURN
  58. 600  REM subroutine to print a single box
  59. 605  COLOR 3
  60. 610  FOR I = R1 + 1 TO R2 - 1
  61. 620   LOCATE I, C1 : PRINT CHR$(179);
  62. 630   LOCATE I, C2 : PRINT CHR$(179);
  63. 640  NEXT I
  64. 650  FOR J = C1 + 1 TO C2 - 1
  65. 660   LOCATE R1, J : PRINT CHR$(196);
  66. 670   LOCATE R2, J : PRINT CHR$(196);
  67. 680  NEXT J
  68. 690   LOCATE R1, C1 : PRINT CHR$(218);
  69. 700   LOCATE R1, C2 : PRINT CHR$(191);
  70. 710   LOCATE R2, C1 : PRINT CHR$(192);
  71. 720   LOCATE R2, C2 : PRINT CHR$(217);
  72. 725  COLOR 7
  73. 730  RETURN
  74. 740  REM ask user to press a key to continue
  75. 750  LOCATE 25,1
  76. 760  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  77. 770  K$ = INKEY$ : IF K$ = "" THEN 770
  78. 780  CLS
  79. 840  CLS
  80. 1000  REM List the Marriages File Program.
  81. 1010  REM By:  Melvin O. Duke.  Last Updated:  24 December 1984.
  82. 1020  REM Open the Persons File
  83. 1030  OPEN "a:persfile" AS #1 LEN = 256
  84. 1040  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  85. 1050  REM open the Marriages File
  86. 1060  OPEN "a:marrfile" AS #2 LEN = 128
  87. 1070  FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  88. 1080  REM Read the Marriage Records
  89. 1090  CLS : LOCATE 21,1
  90. 1100  PRINT "Listing the Records in the Marriages File"
  91. 1110  REC.COUNT = 0
  92. 1120  GOSUB 1140
  93. 1130  GOTO 1210
  94. 1140  LPRINT "  List of the Records in the Marriages File  ";DATE$;"  ";TIME$
  95. 1150  LPRINT
  96. 1160  LPRINT " REC   No.  FATHER";
  97. 1170  LPRINT TAB(42);" No.  MOTHER"
  98. 1180  LPRINT " ---   ---  ------";
  99. 1190  LPRINT TAB(42);" ---  ------"
  100. 1200  RETURN
  101. 1210  FOR I = 1 TO 200
  102. 1220   GET #2,I
  103. 1230   REM verify if valid record
  104. 1240   TT1 = CVS(M1$)
  105. 1250   IF TT1 < 1 THEN 1430
  106. 1260   REC.COUNT = REC.COUNT + 1
  107. 1270   LOCATE 23,1 : PRINT "Listing Record:"; TT1
  108. 1280   LPRINT USING "####"; TT1;
  109. 1290   REM husband
  110. 1300   TT2 = CVS(M2$)
  111. 1310   IF TT2 = 0 THEN GOSUB 1740 ELSE GET #1, TT2 : GOSUB 1450
  112. 1320   REM print the father
  113. 1330   LPRINT TAB(7);
  114. 1340   LPRINT USING "####"; TT2;
  115. 1350   LPRINT "  " + T2$ + ", " + T3$;
  116. 1360   REM wife
  117. 1370   TT3 = CVS(M3$)
  118. 1380   IF TT3 = 0 THEN GOSUB 1740 ELSE GET #1, TT3 : GOSUB 1450
  119. 1390   LPRINT TAB(42);
  120. 1400   LPRINT USING "####"; TT3;
  121. 1410   LPRINT "  " + T2$ + ", " + T3$
  122. 1420   IF REC.COUNT MOD 55 = 0 THEN LPRINT CHR$(12);: GOSUB 1140
  123. 1430  NEXT I
  124. 1440  GOTO 1950
  125. 1450  REM Routine to Extract Personal Information
  126. 1460  T1 = CVS(F1$)
  127. 1470  T2$ = F2$
  128. 1480  FOR J = 1 TO LEN(F2$) -1
  129. 1490   IF RIGHT$(T2$,1)=" " THEN T2$ = LEFT$(T2$,LEN(T2$)-1) ELSE J = LEN(F2$)-1
  130. 1500  T3$ = F3$
  131. 1510  NEXT J
  132. 1520  FOR J = 1 TO LEN(F3$) -1
  133. 1530   IF RIGHT$(T3$,1)=" " THEN T3$ = LEFT$(T3$,LEN(T3$)-1) ELSE J = LEN(F3$)-1
  134. 1540  NEXT J
  135. 1550  T4$ = F4$
  136. 1560  IF T4$ = "M" THEN T4$ = "Male"
  137. 1570  IF T4$ = "F" THEN T4$ = "Female"
  138. 1580  T5 = CVS(F5$)
  139. 1590  T6 = CVS(F6$)
  140. 1600  T7 = CVS(F7$)
  141. 1610  T8$ = F8$
  142. 1620  T9$ = F9$
  143. 1630  T10$ = F10$
  144. 1640  T11$ = F11$
  145. 1650  T12$ = F12$
  146. 1660  T13$ = F13$
  147. 1670  T14$ = F14$
  148. 1680  T15$ = F15$
  149. 1690  T16$ = F16$
  150. 1700  T17$ = F17$
  151. 1710  T18$ = F18$
  152. 1720  T19$ = F19$
  153. 1730  RETURN
  154. 1740  REM Blank out a Record
  155. 1750  T1 = 0
  156. 1760  T2$ = ""
  157. 1770  T3$ = ""
  158. 1780  T4$ = ""
  159. 1790  T5 = 0
  160. 1800  T6 = 0
  161. 1810  T7 = 0
  162. 1820  T8$ = ""
  163. 1830  T9$ = ""
  164. 1840  T10$ = ""
  165. 1850  T11$ = ""
  166. 1860  T12$ = ""
  167. 1870  T13$ = ""
  168. 1880  T14$ = ""
  169. 1890  T15$ = ""
  170. 1900  T16$ = ""
  171. 1910  T17$ = ""
  172. 1920  T18$ = ""
  173. 1930  T19$ = ""
  174. 1940  RETURN
  175. 1950  LPRINT CHR$(12);
  176. 1960  CLOSE #1
  177. 1970  CLOSE #2
  178. 1980  CLS : LOCATE 21,1
  179. 1990  PRINT "End of Program"
  180. 2000  RUN "a:menu"
  181.